home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / parse1.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  12.8 KB  |  356 lines
  1. ;; -*- Mode: LISP; Package: BOXER; Base: 10.; Fonts: CPTFONT -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;;;
  17. ;;; This file contains the upper-level code for parsing boxes
  18. ;;; into LISP  code.  There are two procedures available to call:
  19. ;;;
  20. ;;; PARSE-BOX-INTO-LAMBDA takes a BOX as input and returns a
  21. ;;; lambda  expression representing the box.  The arglist of the
  22. ;;; lambda will  be the arglist of the box.
  23. ;;;
  24. ;;; PARSE-INTO-CODE takes a BOX, ROW, or list of ROWS as input,
  25. ;;; and  returns LISP-evalable code.
  26. ;;;
  27. ;;; PARSE-LIST-INTO-CODE will take a list of elements  and parse
  28. ;;; it into code.
  29. ;;;
  30. ;;; This file is responsible for taking those type of inputs and
  31. ;;; getting the  lowest-level elements of their rows to give to
  32. ;;; the Pratt parser  found in PARSE2, which does the actual work
  33. ;;; of parsing.  General  parsing and special forms are dealt
  34. ;;; with in that file. 
  35. ;;; 
  36. ;;; The interface function in that file is PARSE; it takes a
  37. ;;; list of  symbols, numbers, strings, and boxes and returns an
  38. ;;; evalable form  which PARSE-INTO-CODE or PARSE-BOX-INTO-LAMBDA
  39. ;;; will glom together and wrap in something.
  40. ;;;
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42.  
  43. ;;; Fixes for things that are broken elsewhere in the old
  44. ;;;release.
  45.  
  46.  
  47. (DEFMACRO PARSER-BARF (STRING &rest args)
  48.   `(FERROR ,STRING . ,args))
  49.  
  50. (defun parser-typep (object)
  51.   (cond ((doit-box? object) ':doit-box)
  52.     ((data-box? object) ':data-box)
  53.     (t (typep object))))
  54.  
  55. (defun parser-number-of-args (item)
  56.   (IF (BOX? ITEM) (LENGTH (PARSER-BOXER-ARGLIST ITEM))
  57.       (ldb %%arg-desc-min-args (boxer-args-info item))))
  58.  
  59. (defun entries-on-input-row (box)
  60.   "Returns the entries on the input row of the box, or nil of none."
  61.   (let ((1row-entries (ROW-ENTRIES (tell box :row-at-row-no 0))))
  62.     (IF (memq (car 1row-entries) '(bu:INPUT bu:INPUTS bu:))
  63.     (cdr 1row-entries)
  64.     NIL)))
  65.  
  66. (DEFUN PARSER-BOXER-ARGLIST (BOX)
  67.   "The BOXER-ARGLIST function calls the parser, so we have to have
  68. our own function for getting the arglist out of a doit box.
  69. This function should return the toplevel arglist, without any
  70. destructured variables."
  71.   (check-arg-type box doit-box "a DOIT box")
  72.   (mapcar #'(LAMBDA (entry)
  73.           (if (label-pair? entry)
  74.           (label-pair-label entry)
  75.           entry))
  76.       (entries-on-input-row box)))
  77.  
  78. ;;;Returns the special arglist for destructuring.  It is a list
  79. ;;;which has one item for each arg in the real arglist of the
  80. ;;;a lambda for this box.  The car of each of these items is the name
  81. ;;;of the lisp input, as found in the bvl of the lambda.
  82. ;;;PARSER-BOXER-ARGLIST returns a list of these CARs (i.e., the
  83. ;;;lisp arglist).
  84. ;;;Structure of the elements of the list:  After the lisp name of
  85. ;;;the variable comes any number of lists, one for each row in
  86. ;;;the destructuring box.  Each list contains one or more items,
  87. ;;;which (as now implemented) are the names the corresponding parts
  88. ;;;of the input should be bound to.
  89.  
  90. (DEFUN PARSER-BOXER-ARGLIST-FOR-DESTRUCTURING (BOX)
  91.   (check-arg-type box doit-box "a DOIT box")
  92.   (parser-destructured-args
  93.     (entries-on-input-row box)))
  94.  
  95. (defun parser-destructured-args (entry)
  96.   (cond    ((symbolp entry) entry)
  97.     ((label-pair? entry)
  98.      (cons (label-pair-label entry)
  99.            (parser-destructured-args (label-pair-element entry))))
  100.     ((listp entry)
  101.      (mapcar #'parser-destructured-args entry))
  102.     ((data-box? entry)
  103.      (remq nil
  104.            (mapcar #'(lambda (row)
  105.                (parser-destructured-args 
  106.                  (row-entries row)))
  107.                (box-rows entry))))
  108.     (t (parser-barf "~S -- not recognized input object" entry))))
  109.  
  110. ;;;Flattens out a list.  When called on a destructuring arglist, returns
  111. ;;;a list of all the variables involved.
  112. (defun flatten-list (list)
  113.   (cond ((null list) nil)
  114.     ((atom (car list))
  115.      (cons (car list)
  116.            (flatten-list (cdr list))))
  117.     (t (nconc (flatten-list (car list))
  118.           (flatten-list (cdr list))))))
  119.  
  120.  
  121. ;;;Given a BOX, return a lambda expression representing the box.
  122. ;;;The arglist of the lambda is the arglist of the box.  Any
  123. ;;;destructuring is done by the destructuring code in the lambda.
  124.  
  125. ;;;The rest of the lambda body is constructed of all the rows of
  126. ;;;the box run through PARSE-ROW-INTO-CODE.
  127.  
  128. ;;;PARSE-ROW-INTO-CODE is given (in addition to the row) a list
  129. ;;;of variables (probably not yet bound) to be considered bound
  130. ;;;to data objects.  Note that all the destructured variables
  131. ;;;must be included in this list.  The order doesn't matter:
  132. ;;;it's just so PARSE-ROW-INTO-CODE will understand them when it
  133. ;;;comes to them.
  134.  
  135. ;;;Once we allow functions as arguments the variable must be
  136. ;;;declared to be a function in the arglist, so we can pass that
  137. ;;;information along to parse-row-into-code also.
  138.  
  139. (defun parse-box-into-lambda (box)
  140.   (check-arg-type box doit-box "a DOIT box")
  141.   (let* ((INPUTS-FOR-LAMBDA (mapcar #'(lambda (input)
  142.                     (if (box? input)  ;destructured
  143.                         (gensym)      ;but without a name.
  144.                         input))      ;this doesn't work right.
  145.                     (parser-boxer-arglist box)))
  146.      (rows (if (null inputs-for-lambda)
  147.            (box-rows box)
  148.            (cdr (box-rows box))))
  149.      (DESTRUCTURED-ARGUMENTS-LIST
  150.        (parser-boxer-arglist-for-destructuring box))
  151. ;     (local-definitions (find-local-definitions rows))
  152. ;     (local-procedures (car local-definitions))
  153. ;     (local-variables (cadr local-definitions))
  154.      (arglist-variables (flatten-list destructured-arguments-list))
  155.      (BODY
  156.        (delq nil (mapcar #'(LAMBDA (row)
  157.                  (PARSE-ROW-INTO-CODE
  158.                    ROW
  159.                    NIL
  160.                    NIL
  161.                    ;local-variables
  162.                    ;local-procedures
  163.                    arglist-variables))
  164.                  rows))))
  165.     (cond ((null body) `(LAMBDA () ',INPUTS-FOR-LAMBDA NIL))
  166.       ((some destructured-arguments-list #'listp)      ;Any destructuring?
  167.        `(LAMBDA ()
  168.           ',inputs-for-lambda      ;just for show
  169.           (*CATCH 'STOP-EXECUTING-THIS-BOX
  170.         (bind-destructure-arguments
  171.           ,inputs-for-lambda
  172.           ,(parser-boxer-arglist-for-destructuring box)
  173.           .,body))))
  174.       (t
  175.        `(LAMBDA  ()
  176.           ',INPUTS-FOR-LAMBDA      ;just for show
  177.           (*CATCH 'STOP-EXECUTING-THIS-BOX
  178.             .,body))))))
  179.                
  180. ;This needs to use with-boxer-bindings rather than let*.
  181. (defmacro bind-destructure-arguments (lambda-list destr-list &body body)
  182.   (let ((gensym-value-list (mapcar #'(lambda (ignore) (gensym)) lambda-list)))
  183.     `(let (,@(mapcar #'(lambda (gensym-value-name value)
  184.               `(,gensym-value-name (box-items-list (boxer-symeval ',value))))
  185.               gensym-value-list
  186.               lambda-list))
  187.        (boxer-let* ,(binding-list destr-list gensym-value-list)
  188.      .,body))))
  189.  
  190.  
  191. ;generates a binding list given a list of destructuring patterns
  192. ;and the gensymmed variables containing the lists with the values.
  193. (defun binding-list (description-list gensym-list)
  194.   (apply #'append              ;crock
  195.      (mapcar #'(lambda (description gensym-containing-value)
  196.              (binding-list-1 (cdr description)
  197.                      gensym-containing-value))
  198.          description-list
  199.          gensym-list)))
  200.  
  201. ;path is initially a gensymmed variable name containig a list of values
  202. ;to fit the desription, but it has cars and cdrs prepended to it.
  203. (defun binding-list-1 (description path)
  204.   (if (null description) nil
  205.       (append
  206.     (binding-list-2 (car description) (list 'car-not-nil path))
  207.     (binding-list-1 (cdr description) (list 'cdr-not-nil path)))))
  208.  
  209.  
  210. (defun binding-list-2 (description path)
  211.   (if (null description) nil
  212.       (cons (list (car description) `(car-not-nil ,path))
  213.         (binding-list-2 (cdr description) (list 'cdr-not-nil path)))))
  214.  
  215.  
  216. (defun car-not-nil (arg)
  217.   (if (not (null arg)) (car arg)
  218.       (parser-barf "Some argument to the current function is a destructured box ~
  219.  with the wrong number of elements.")))
  220.  
  221. (defun cdr-not-nil (arg)
  222.   (if (not (null arg)) (cdr arg)
  223.       (parser-barf "Some argument to the current function is a destructured box ~
  224.  with the wrong number of elements.")))
  225.  
  226.  
  227. ;bind-destructure-arguments is a hairy macro that converts this:
  228. ;(bind-destructuring-arguments
  229. ;      (part1 part2)
  230. ;      ((part1 (a b) (c d))
  231. ;       (part2 (x y z)))
  232. ;   (boxer-funcall bu:mumble a b x y z))
  233.  
  234. ;into something like this:
  235. ;(let ((part1-list (box-items part1))
  236. ;      (part2-list (box-items part2)))
  237. ;  (let ((a (car (car part1-list)))
  238. ;    (b (cadr (car part1-list)))
  239. ;    (c (car (cadr part1-list)))
  240. ;    (d (cadr (cadr part1-list)))
  241. ;    (x (car (car part2-list)))
  242. ;    (y (cadr (car part2-list)))
  243. ;    (z (caddr (car part2-list))))
  244. ;    (boxer-funcall bu:mumble a b x y z)))
  245. ;except part1-list and part2-list are GENSYMS.
  246.  
  247. (defun box-items-list (box)
  248.   (check-arg-type box data-box "a data box")
  249.   (mapcar #'row-entries
  250.       (box-rows box)))
  251.  
  252. ;;; This takes a ROW and returns what it parses into.  The
  253. ;result should be object that EVAL will like.  Since we
  254. ;aren't parsing a box, there's no lambda-list to worry about.
  255. ;Any  definitions encountered should be done.
  256.  
  257. (DEFUN parse-into-code (stuff)
  258.   (cond    ((or (listp stuff) (null stuff))
  259.      (parse-rows-as-code stuff))
  260.     ((row? stuff) (parse (tell stuff :ENTRIES)))
  261.     ((box? stuff) `(BOXER-FUNCALL ,(list 'QUOTE stuff)))
  262.     ((or (numberp stuff) (stringp stuff)) stuff)
  263.     (T
  264.      (parser-BARF "~s cannot be parsed" STUFF))))
  265.  
  266. ;;; Takes a list of rows and returns a PROGN.  Again, no variables
  267. ;;; that aren't bound need be considered.
  268. (DEFUN PARSE-ROWS-AS-CODE (ROWS)
  269.   `(PROGN .,(MAPCAR #'parse-row-into-code rows)))
  270.  
  271. (DEFUN PARSE-ROW-INTO-CODE (ROW &REST ARGS)
  272.   (LEXPR-FUNCALL #'PARSE (TELL ROW :ENTRIES) ARGS))
  273.  
  274. (deff parse-list-into-code 'parse)
  275.  
  276. ;Returns two values: procedures and variables defined with  in
  277. ;the box.  Things must be defined as first thing on the line.
  278. ;Probably some problem with label-pairs.  FOO:BARbaz.
  279. ;Simplifying assumption:
  280. ;If the object following the  is a DOIT-BOX, then it's a procedure,
  281. ;otherwise it's a variable.
  282. ;Returns a list of procedures (car) and variables (cadr).
  283. ;Each procedure is a list of the name, the doit box, and the data type.
  284. ;Each variable is a list of the name and the value.
  285.  
  286. (DEFMACRO PARSER-PROCEDURE-SYMBOL-DESCRIPTOR-NUMBER-OF-ARGS (THING)
  287.   `(CADDR ,THING))
  288.  
  289. (DEFMACRO PARSER-PROCEDURE-SYMBOL-DESCRIPTOR-VALUE (THING)
  290.   `(CADR ,THING))
  291.  
  292. (DEFMACRO PARSER-PROCEDURE-SYMBOL-DESCRIPTOR-NAME (THING)
  293.   `(CAR ,THING))
  294.  
  295. (DEFMACRO MAKE-PARSER-PROCEDURE-SYMBOL-DESCRIPTOR (NAME VALUE NARGS)
  296.   `(LIST ,NAME ,VALUE ,NARGS))
  297.  
  298. ;(defun find-local-definitions (box-rowlist)
  299. ;  (loop for row in box-rowlist
  300. ;        for entry = (car (row-entries row))
  301. ;    when (name-pair? entry)
  302. ;          when (doit-box? (name-pair-element entry))
  303. ;      collect (MAKE-PARSER-PROCEDURE-SYMBOL-DESCRIPTOR
  304. ;            (name-pair-name entry)
  305. ;            (name-pair-element entry)
  306. ;            (parser-number-of-args (name-pair-element entry)))
  307. ;                     into procedures
  308. ;          else collect (list (name-pair-name entry)
  309. ;                 (name-pair-element entry))
  310. ;             into variables
  311. ;    finally
  312. ;    (return (list procedures variables))))
  313.  
  314.  
  315. ;Given a box, this function goes through and executes all the "" definitions
  316. ;in the box, and all its sub-boxes.  It's for use right after READ, etc.
  317. ;Note that map-over-all-inferior-boxes doesn't do the current-box...
  318.  
  319. ;(defun process-box-local-definitions (box)
  320. ;  (check-box-arg box)
  321. ;  (let ((*currently-executing-box* nil)        ;Let this happen as if it were done
  322. ;    (*boxer-binding-alist-root* nil))    ;at toplevel inside each box so it will
  323. ;                        ;side effect the boxes.
  324. ;    (process-one-boxes-local-definitions
  325. ;      box)
  326. ;    (map-over-all-inferior-boxes
  327. ;      box
  328. ;      'process-one-boxes-local-definitions)))
  329.  
  330. (COMPILER:MAKE-OBSOLETE process-box-local-definitions "It was used for handling 's")
  331.  
  332. ;(defun process-one-boxes-local-definitions (box)
  333. ;  (let ((*boxer-static-variables-root* box))
  334. ;    (mapc #'(lambda (row)
  335. ;          (if (row-contains-character? row *naming-code*)
  336. ;          (let ((entry (car (row-entries row))))
  337. ;            (cond ((name-pair? entry)
  338. ;               (boxer-make (name-pair-name entry)
  339. ;                    (name-pair-element entry))
  340. ;               (if (box? (name-pair-element entry))
  341. ;                   (tell (name-pair-element entry)
  342. ;                     :set-name
  343. ;                     (name-pair-name entry))))))))
  344. ;      (box-rows box))))
  345.  
  346. (COMPILER:MAKE-OBSOLETE process-one-boxes-local-definitions "It was used for handling 's")
  347.  
  348. ;temporary -- move to emanip
  349. (defun row-contains-character? (row character)
  350.   (let* ((array (tell row :chas-array))
  351.      (length (array-active-length array)))
  352.     (do* ((i 0 (1+ i)))
  353.      ((= i length) nil)
  354.       (if (eq character (cha-code (aref array i)))
  355.       (return t)))))
  356.